use "reader.sml" ;

datatype Expr	= Const of Sexpr
				| Var of string
				| VarFree of string
				| VarParam of string * int
				| VarBound of string * int * int
				| If of Expr * Expr * Expr
				| Abs of (string list) * Expr
				| AbsOpt of (string list) * string * Expr
				| AbsVar of string * Expr
				| App of Expr * (Expr list)
				| AppTP of Expr * (Expr list)
				| Seq of Expr list
				| Or of Expr list
				| Set of Expr * Expr
				| Def of Expr * Expr;

exception ErrorReservedWordUsedImproperly of string;
exception ErrorMalformedLambdaArgList of string;
exception UnrecognizedAST of Sexpr;
exception NotASymbol of Sexpr;
exception ErrorMoreThanOneExpr;

signature TAG_PARSER =
sig
    val stringToPE : string -> Expr;
    val stringToPEs : string -> Expr list;
end;

exception NotAList of Sexpr;

(***************************************************************************************
  												 						TAG PARSER
***************************************************************************************)

structure TagParser : TAG_PARSER =
struct

	val reservedSymbols = ["and", "begin", "cond", "define", "else",
				"if", "lambda", "let", "let*", "letrec",
				"or", "quote", "set!"];

	fun	MLListToScheme [] = Nil
	|	MLListToScheme (a :: s) = Pair(a, (MLListToScheme s));

	(* add to end of list *)
	fun	combine(Nil, e) = e
	|	combine(Pair(car, cdr), e) = Pair(car, combine(cdr, e))
	|	combine(someSexpr, e) = raise ErrorOnlyCombinesPairs(someSexpr) ;

	fun reservedWord(str) = ormap (fn rs => (String.compare(rs, str) = EQUAL)) reservedSymbols;

	fun schemeListToML Nil = []
	| schemeListToML (Pair(car, cdr)) = car :: (schemeListToML cdr)
	| schemeListToML e = raise NotAList(e);

	fun identity(x) = x ;

	(* first n-1 elements and last element *)
	fun	scmRdcAndRac(Nil, retRdcRac) = retRdcRac(Nil, Nil)
	|	scmRdcAndRac(Pair(car, cdr), retRdcRac) = scmRdcAndRac(cdr, (fn (rdc, rac) => retRdcRac(Pair(car, rdc), rac)))
	|	scmRdcAndRac(e, retRdcRac) = retRdcRac(Nil, e);

	fun schemeMap(list, func) = MLListToScheme(map func (schemeListToML(list))) ;

	(* these procedures make the convenient workable form from the non-workable one *)
 	fun makeSchemeSingleton(sexpr) = Pair(sexpr, Nil) ;
	fun	makeSchemeBegin(list) = makeListSexpr([Symbol "begin"], list, identity) ;
 	fun	makeSchemeIf(test, restrue, resfalse) = makeListSexpr([Symbol "if", test, restrue, resfalse], Nil, identity) ;
 	fun makeSchemeOr(sexprs) = makeListSexpr((Symbol "or") :: sexprs, Nil, identity) ;
 	fun	makeSchemeSet(variable, value) = makeListSexpr([Symbol "set!", variable, value], Nil, identity) ;
 	fun	makeSchemeLambda(arglist, body) = makeListSexpr([Symbol "lambda", arglist, makeSchemeBegin(body)], Nil, identity) ;
 	fun	makeSchemeLet(bindings, body) = makeListSexpr([Symbol "let", bindings, makeSchemeBegin(body)], Nil, identity) ;
 	fun makeSchemeCond(clauses) = makeListSexpr([Symbol "cond"], clauses, identity) ;
 	fun	makeSchemeApp(func, args) = Pair(func, args) ;

	(* all expansions assume the given arguments are in NOT in convenient workable form and return a workable one *)
	fun	expandAnd(Nil) = Bool(true)
	|	expandAnd(Pair(last, Nil)) = last
	|	expandAnd(Pair(car, cdr)) = makeSchemeIf(car, expandAnd(cdr), Bool false)
	|	expandAnd(x) = raise UnrecognizedAST x ;

	fun	expandCond(Nil) = raise ErrorReservedWordUsedImproperly "cond"
	|	expandCond(Pair(Pair(Symbol "else", body), Nil)) = makeSchemeBegin(body)
	|	expandCond(Pair(Pair(test, Nil), Nil)) = makeSchemeOr([test, Void])
	|	expandCond(Pair(Pair(test, body), Nil)) = makeSchemeIf(test, makeSchemeBegin(body), Void)
	|	expandCond(Pair(Pair(test, Nil), clauses)) = makeSchemeOr([test, makeSchemeCond(clauses)])
	|	expandCond(Pair(Pair(test, body), clauses)) = makeSchemeIf(test, makeSchemeBegin(body), makeSchemeCond(clauses))
	|	expandCond(x) = raise UnrecognizedAST x ;

	fun	expandLet(_, Nil) = raise ErrorReservedWordUsedImproperly "let" (* no body *)
	(*|	expandLet(Nil, body) = makeSchemeBegin(body)*)
	|	expandLet(bindings, body) =
		let
			val exn = UnrecognizedAST bindings

			val vars =
				schemeMap(
					bindings,
					(fn Pair(car, Pair(_, Nil)) => car
					| _ => raise exn)
				)
			handle NotAList(x) => raise UnrecognizedAST x ;

			val vals =
				schemeMap(
					bindings,
					(fn Pair(_, Pair(cadr, Nil)) => cadr
					| _ => raise exn)
				)
			handle NotAList(x) => raise UnrecognizedAST x ;
		in
			makeSchemeApp(makeSchemeLambda(vars, body), vals)
		end ;

	fun	expandStarlet(_, Nil) = raise ErrorReservedWordUsedImproperly "let*" (* no body *)
 	(*|	expandStarlet(Nil, body) = makeSchemeBegin(body)*)
 	|	expandStarlet(Nil, body) = makeSchemeLet(Nil, body)
	|	expandStarlet(Pair(binding as Pair(_, Pair(_, Nil)), Nil), body) =
 			makeSchemeLet(
				makeSchemeSingleton(binding),
				body
			)
	|	expandStarlet(Pair(binding as Pair(_, Pair(_, Nil)), remaining), body) =
 			makeSchemeLet( (* need to give the non-workable form of the 'body' argument *)
				makeSchemeSingleton(binding),
				makeSchemeSingleton(expandStarlet(remaining, body))
			)
	|	expandStarlet(x, _) = raise UnrecognizedAST x ;

	fun	expandLetrec(_, Nil) = raise ErrorReservedWordUsedImproperly "letrec"
 	(*|	expandLetrec(Nil, body) = makeSchemeBegin(body)*)
 	|	expandLetrec(Nil, body) = makeSchemeLet(Nil, body)
	|	expandLetrec(bindings, body) =
			let
				val	variables =
					schemeMap(
						bindings,
						fn	(Pair(v, _)) => makeListSexpr([v, Bool false], Nil, identity)
						|	_ => raise UnrecognizedAST bindings
					)
				handle NotAList(x) => raise UnrecognizedAST x ;

				val	assignments =
					schemeMap(
						bindings,
						fn	(Pair(variable, Pair(value, Nil))) => makeSchemeSet(variable, value)
						|	_ => raise UnrecognizedAST bindings
					)
				handle NotAList(x) => raise UnrecognizedAST x ;
			in
				makeSchemeLet(variables, combine(assignments, makeSchemeSingleton(makeSchemeLet(Nil, body))))
			end

	fun	parseExpr(Void) = Const(Void)
	|	parseExpr(Nil) = Const(Nil)
	|	parseExpr(e as Number(_)) = Const(e)
	|	parseExpr(e as Char(_)) = Const(e)
	|	parseExpr(e as Bool(_)) = Const(e)
	|	parseExpr(e as String(_)) = Const(e)
	|	parseExpr(e as Vector(_)) = Const(e)
	|	parseExpr(Pair(Symbol("quote"), Pair(e, Nil))) = Const(e)
	|	parseExpr(Symbol(e)) =
			if reservedWord(e)
				then raise ErrorReservedWordUsedImproperly(e)
				else Var(e)
	|	parseExpr(Pair(Symbol("and"), list)) = parseExpr(expandAnd(list))
	|	parseExpr(Pair(Symbol("or"), list)) = makeOr(list)
	|	parseExpr(Pair(Symbol "begin", list)) = makeSeq(list)
	|	parseExpr(Pair(Symbol("cond"), list)) = parseExpr(expandCond(list))
	|	parseExpr(Pair(Symbol("set!"), Pair(name as Symbol(_), Pair(value, Nil)))) = Set(parseExpr name, parseExpr value)
	|	parseExpr(Pair(Symbol("set!"), Pair(name, _))) = raise ErrorReservedWordUsedImproperly "set!"
	|	parseExpr( (* let *)
			Pair(Symbol("let"),
				Pair(bindings,
				body))) =
			parseExpr(expandLet(bindings, body))
	|	parseExpr( (* let* *)
			Pair(Symbol("let*"),
				Pair(bindings,
				body))) =
			parseExpr(expandStarlet(bindings, body))
	|	parseExpr( (* letrec *)
			Pair(Symbol("letrec"),
				Pair(bindings,
				body))) =
			parseExpr(expandLetrec(bindings, body))
	|	parseExpr( (* if-then *)
			Pair(Symbol("if"), Pair(test,
					Pair(dit, Nil)))) =
			If(parseExpr(test), parseExpr(dit), Const(Void))
	|	parseExpr( (* if-then-else *)
			Pair(Symbol("if"), Pair(test,
				Pair(dit,
				Pair(dif, Nil))))) =
			If(parseExpr(test), parseExpr(dit), parseExpr(dif))
	|	parseExpr( (* lambda error *)
			Pair(ast as Symbol("lambda"), Pair(argl,
				Nil))) = (* no body *)
			raise UnrecognizedAST ast
	|	parseExpr( (* lambda *)
			Pair(Symbol("lambda"), Pair(argl,
				body))) =
			let
				fun arglist(Nil) = []
				|	arglist(Pair(Symbol(name), list)) = name :: arglist(list)
				|	arglist(Pair(sexpr, _)) = raise NotASymbol sexpr
				|	arglist(_) = raise ErrorMalformedLambdaArgList "argl"
			in
				scmRdcAndRac(
					argl,
					fn	(Nil, Symbol rac) => AbsVar(rac, parseExpr(makeSchemeBegin(body)))
					|	(rdc, Nil) => Abs(arglist(rdc), parseExpr(makeSchemeBegin(body)))
					|	(Nil, x) => raise ErrorMalformedLambdaArgList "argl"
					(*|	(Nil, Symbol(rac)) => raise ErrorMalformedLambdaArgList "argl"*)
					|	(rdc, Symbol(rac)) => AbsOpt(arglist(rdc), rac, parseExpr(makeSchemeBegin(body)))
					|	(_, x) => raise NotASymbol x
				)
			end
	|	parseExpr( (* MIT style define error *)
			Pair(ast as Symbol("define"),
				Pair(  Pair(name, args),
				Nil))) = (* no body *)
			raise UnrecognizedAST ast
	|	parseExpr( (* MIT style define *)
			Pair(Symbol("define"),
				Pair(  Pair(name, args),
				body))) =
			Def(parseExpr name, parseExpr (makeSchemeLambda(args, body)))
	|	parseExpr( (* regular define *)
			Pair(Symbol("define"), Pair(name,
				Pair(value, Nil)))) =
			Def(parseExpr name, parseExpr value)
	|	parseExpr( (* regular define error *)
			Pair(ast as Symbol("define"), Pair(name,
				Pair(value, tooManyValues)))) =
			raise UnrecognizedAST ast
	|	parseExpr (e as Pair(p, q)) = (* application *)
			scmRdcAndRac(
				q,
				(fn	(rdc, Nil) => App(parseExpr(p), map parseExpr(schemeListToML(rdc)))
				|	_ => raise UnrecognizedAST(e))
			)

	and	makeOr(Nil) = parseExpr(Bool(false))
	|	makeOr(Pair(last, Nil)) = parseExpr last
	|	makeOr(list as Pair(_,_)) = Or(map parseExpr (schemeListToML list))
	|	makeOr(e) = raise ErrorReservedWordUsedImproperly("or")

	and	makeSeq(Nil) = parseExpr Void
	|	makeSeq(Pair(last, Nil)) = parseExpr last
	|	makeSeq(list as Pair(_,_)) = Seq(map parseExpr (schemeListToML list))
	|	makeSeq(sexpr) = raise ErrorReservedWordUsedImproperly "begin"(*parseExpr sexpr *) ;

	fun	multiParseExpr [] = []
	|	multiParseExpr(sexpr :: remaining) = parseExpr(sexpr) :: multiParseExpr(remaining) ;

	fun stringToPE string = parseExpr(Reader.stringToSexpr string) ;

	fun stringToPEs string =  multiParseExpr(Reader.stringToSexprs string);

end; (* of structure TagParser *)

